home *** CD-ROM | disk | FTP | other *** search
/ System Booster / System Booster.iso / Archives / GNU / GNU_SMALLTALK.lha / fileout-ps.st < prev    next >
Encoding:
Text File  |  1992-02-16  |  8.0 KB  |  327 lines
  1. "======================================================================
  2. |
  3. |   File out method definitions as PostScript.
  4. |
  5.  ======================================================================"
  6.  
  7. "======================================================================
  8. |
  9. | Copyright (C) 1990, 1991, 1992 Free Software Foundation, Inc.
  10. | Written by Steve Byrne.
  11. |
  12. | This file is part of GNU Smalltalk.
  13. |
  14. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  15. | under the terms of the GNU General Public License as published by the Free
  16. | Software Foundation; either version 1, or (at your option) any later version.
  17. | 
  18. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  19. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  20. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  21. | details.
  22. | 
  23. | You should have received a copy of the GNU General Public License along with
  24. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  25. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  26. |
  27.  ======================================================================"
  28.  
  29. "
  30. |     Change Log
  31. | ============================================================================
  32. | Author       Date       Change 
  33. | sbb         16 Feb 92      created Feb 92.
  34. |
  35. "
  36.  
  37. !String methodsFor: 'useful functionality'!
  38.  
  39. linesDo: aBlock
  40.     "Send 'aBlock' a substring of the receiver for each newline delimited
  41.      line in the receiver"
  42.     | start substr |
  43.     start _ 1.
  44.     1 to: self size do:
  45.     [ :i | (self at: i) == Character nl
  46.            ifTrue: [ substr _ self copyFrom: start to: i - 1.
  47.                  aBlock value: substr.
  48.                  start _ i + 1. ]
  49.           ].
  50.     "start - 1 <= self size   this includes the blank line at the end"
  51.     start <= self size
  52.     ifTrue: [ aBlock value: (self copyFrom: start to: self size) ]
  53. !
  54.  
  55. tabExpand
  56.     "Replace tabs in self with appropriate number of spaces"
  57.     | hpos dest |
  58.     hpos _ 1.
  59.     dest _ String new: (self size * 8).
  60.     self do:
  61.     [ :ch | ch == Character tab
  62.             ifTrue: [ [ dest at: hpos put: Character space.
  63.                 hpos _ hpos + 1.
  64.                 (hpos \\ 8) ~= 1 ] whileTrue.
  65.                   ]
  66.             ifFalse: [ (ch == $( ) | (ch == $) )
  67.                    ifTrue: [ dest at: hpos put: $\.
  68.                          hpos _ hpos + 1 ].
  69.                    dest at: hpos put: ch.
  70.                    hpos _ hpos + 1 ]
  71.             ].
  72.     ^dest copyFrom: 1 to: hpos - 1
  73. ! !
  74.  
  75. "Execute to test:
  76. ----------------------------------------------------------------------
  77. 'foo
  78. bar
  79. baz
  80. ' linesDo: [ :aLine | aLine printNl ]!
  81. ----------------------------------------------------------------------
  82. "
  83.  
  84.  
  85.  
  86. !ClassDescription methodsFor: 'filing'!
  87.  
  88. filePostscriptOutOn: aFileStream
  89.     | categories now |
  90.     categories _ Set new.
  91.     methodDictionary isNil ifTrue: [ ^self ].
  92.     methodDictionary do:
  93.     [ :method | categories add: (method methodCategory) ].
  94.  
  95.     self emitPostscriptHeader: aFileStream.
  96.  
  97.     aFileStream nextPutAll: 'normal'; nl;
  98.     nextPutAll: '(''Filed out from ';
  99.     nextPutAll: Version;
  100.     nextPutAll: ' on '.
  101.     now _ Date dateAndTimeNow.
  102.     aFileStream print: (now at: 1);
  103.     nextPutAll:  '  ';
  104.     print: (now at: 2);
  105.     nextPutAll: ' GMT''!)'; 
  106.     nextPutAll: ' show newline newline'; nl; nl.
  107.  
  108.     categories asSortedCollection do:
  109.         [ :category | self emitPostscriptCategory: category toStream: aFileStream ].
  110.  
  111.     aFileStream nextPutAll: 'finish'; nl.
  112. ! !
  113.  
  114.  
  115. !ClassDescription methodsFor: 'private'!
  116.  
  117. emitPostscriptCategory: category toStream: aFileStream
  118.     "I write Postscript for legal Smalltalk load syntax definitions of all of my methods
  119.      are in the 'category' category to the aFileStream"
  120.  
  121.     aFileStream nextPutAll: 'italic'; nl;
  122.     nextPutAll: '(!';
  123.     print: self;
  124.     nextPutAll: ' methodsFor: ''';
  125.     nextPutAll: category;
  126.     nextPutAll: '''!)';
  127.     nextPutAll: ' show '; nl.
  128.     methodDictionary notNil
  129.       ifTrue: [ methodDictionary do:
  130.               [ :method | (method methodCategory) = category
  131.                       ifTrue: [ self emitPostscriptMethod: method
  132.                          toStream: aFileStream ]
  133.                       ] ].
  134.     aFileStream nextPutAll: '(!) show newline
  135. newline newline
  136. '
  137. !
  138.  
  139. emitPostscriptMethod: method toStream: aFileStream
  140.     self splitOffSelector: method methodSourceString
  141.      to: [ :sel :body | aFileStream nextPutAll: 'newline newline'; nl;
  142.                 nextPutAll: 'bold'; nl.
  143.                 self emitLines: sel toStream: aFileStream.
  144.                 aFileStream nextPutAll: 'normal'; nl.
  145.                 self emitLines: body toStream: aFileStream.
  146.                 aFileStream nextPutAll: '(! ) show '; nl.
  147.                 ] 
  148. !
  149.  
  150.  
  151. splitOffSelector: methodString to: aBlock
  152.     | sel body ch split pos |
  153.     ch _ methodString at: 1.    "could skip whitespace"
  154.     ch isAlphaNumeric
  155.     ifTrue: [ split _ self parseUnaryOrKeyword: methodString ]
  156.     ifFalse: [ pos _ self skipToWhite: 1 on: methodString.
  157.            pos _ self skipWhite: pos on: methodString.
  158.            pos _ self skipIdentifier: pos on: methodString.
  159.            split _ self skipPastNewline: pos on: methodString ].
  160.     sel _ methodString copyFrom: 1 to: split - 1.
  161.     body _ methodString copyFrom: split to: methodString size.
  162.     aBlock value: sel value: body
  163. !
  164.  
  165. skipToWhite: start on: string
  166.     | pos |
  167.     pos _ start.
  168.     [ (string at: pos) isSeparator ]
  169.     whileFalse: [ pos _ pos + 1].
  170.     ^pos
  171. !
  172.  
  173. skipWhite: start on: string
  174.     | pos |
  175.     pos _ start.
  176.     [ (string at: pos) isSeparator ]
  177.     whileTrue: [ pos _ pos + 1].
  178.     ^pos
  179. !
  180.  
  181. skipIdentifier: start on: string
  182.     | pos |
  183.     pos _ start.
  184.     [ (string at: pos) isAlphaNumeric ]
  185.     whileTrue: [ pos _ pos + 1].
  186.     ^pos
  187. !    
  188.  
  189. skipPastNewline: start on: string
  190.     | pos ch |
  191.     pos _ start.
  192.     [ ch _ string at: pos.
  193.       (ch isSeparator) and: [ ch ~~ Character nl] ]
  194.     whileTrue: [ pos _ pos + 1].
  195.     ch == Character nl
  196.     ifTrue: [ pos _ pos + 1 ].
  197.     ^pos
  198. !    
  199.  
  200. parseUnaryOrKeyword: string
  201.     | pos ch tempPos |
  202.     pos _ self skipIdentifier: 1 on: string.
  203.     ch _ string at: pos.
  204.     ch ~~ $:
  205.     ifTrue: [ "Got a unary selector"
  206.           pos _ self skipPastNewline: pos on: string.
  207.           ^pos ].
  208.     pos _ 1.
  209.     [ tempPos _ self skipWhite: pos on: string.
  210.       ch _ string at: tempPos.
  211.      "make sure we have a valid keyword identifier to start"
  212.       ch isLetter 
  213.       ifFalse: [ ^self skipPastNewline: pos on: string ].
  214.       tempPos _ self skipIdentifier: tempPos on: string.
  215.       ch _ string at: tempPos.
  216.       ch ~~ $:
  217.       ifTrue: [ ^self skipPastNewline: pos on: string ].
  218.      "parsed a keyword, expect an identifier next"
  219.       tempPos _ self skipWhite: tempPos + 1 on: string.
  220.       ch _ string at: tempPos.
  221.       ch isLetter 
  222.       ifFalse: [ ^self skipPastNewline: pos on: string ].
  223.       pos _ self skipIdentifier: tempPos on: string.
  224.       true ] whileTrue
  225. !
  226.  
  227. emitLines: string toStream: aStream
  228.     string linesDo: [ :line | aStream nextPut: $(;
  229.                   nextPutAll: line tabExpand;
  230.                   nextPutAll: ') show newline'; nl ]
  231. !
  232.  
  233.  
  234. emitPostscriptHeader: aFileStream
  235.     aFileStream nextPutAll: 
  236. '%!
  237.  
  238. %%%
  239. %%% User settable parameters
  240. %%%
  241.  
  242. /fontSize 10 def
  243. /leading 2 def
  244. /indent 0 def
  245.  
  246.  
  247. %%% 
  248. %%% End of user settable parameters
  249. %%%
  250.  
  251. clippath pathbbox 
  252.   /uy exch def
  253.   /ux exch def
  254.   /ly exch def
  255.   /lx exch def
  256.  
  257.  
  258. /lineHeight fontSize leading add def
  259.  
  260. /ystart uy lineHeight sub def
  261. /ypos ystart def
  262.  
  263. /linecounter 0 def
  264. /maxline
  265.     uy ly sub                % height
  266.     lineHeight              % line_height height
  267.     div floor            % max_whole_lines_per_page
  268. def
  269.  
  270. /Helvetica findfont fontSize scalefont /hel exch def
  271. /Helvetica-Bold findfont fontSize scalefont /helb exch def
  272. /Helvetica-Oblique findfont fontSize scalefont /heli exch def
  273.  
  274. /normal {
  275.     hel setfont
  276. } def
  277.  
  278. /bold {
  279.     helb setfont
  280. } def
  281.  
  282. /italic {
  283.     heli setfont
  284. } def
  285.  
  286. /newline { % - => -
  287.     /ypos ypos lineHeight sub def
  288.     /linecounter linecounter 1 add def
  289.     linecounter maxline 1 sub ge
  290.     {
  291.     showpage
  292.         /ypos ystart def
  293.     /linecounter 0 def
  294.     } if
  295.     indent ypos moveto
  296. } def
  297.  
  298. /finish { % - => -
  299.     linecounter 0 gt
  300.     { showpage }
  301.     if
  302. } def 
  303.  
  304. indent ypos moveto
  305.  
  306.  
  307.  
  308. '
  309.  
  310. ! !
  311.  
  312. "Some test code.  Eval the region in comments after you've filed it in."
  313.  
  314. "SymLink filePostscriptOutOn: stdout!"
  315.  
  316. "
  317. | pipe |
  318.     pipe _ FileStream popen: 'lpr' dir: 'w'.
  319.     Association filePostscriptOutOn: pipe.
  320.     pipe close
  321. !
  322. "
  323.  
  324. "
  325. Object filePostscriptOutOn: stdout!
  326. "
  327.